home *** CD-ROM | disk | FTP | other *** search
/ ETO Development Tools 4 / ETO Development Tools 4.iso / Tools - Objects / MacApp / MacApp 3.0a2 / Libraries / UPascalObject.a < prev    next >
Encoding:
Text File  |  1991-05-01  |  13.0 KB  |  448 lines  |  [TEXT/MPS ]
  1. ;=============================================================================
  2. ; Object Pascal Library Routines
  3. ;
  4. ; Copyright © 1984-1990 Apple Computer, Inc.  All rights reserved.
  5. ;
  6. ; NOTE:
  7. ;    The optimizer redirects the following procedure name
  8. ;
  9. ;%_METHOD           becomes      %_JMPTOTRAP
  10. ;
  11.  
  12.                 Blanks        On
  13.                 String        AsIs
  14.                 Case        On
  15.  
  16.                 Print        Off
  17.                 Include     'Macros.a'
  18.                 Include     'Traps.a'
  19.  
  20.                 LOAD            'ProgStrucMacs.d'
  21.                 LOAD            'FlowCtlMacs.d'
  22.                 Print        On
  23.  
  24. ;---------------------------------------------------------------------------------------------------
  25. ;    tests testClass for being a member of the superClass
  26. ;        uses A0,A1,D0,D1
  27.  
  28.                 Seg         'MAObjectRes'
  29.     If qModelFarCode then
  30. EXPORT FUNCTION ISCLASSIDMEMBERCLASS(testClassID:L, superClassID:L):B
  31.     Else
  32. EXPORT FUNCTION ISCLASSIDMEMBERCLASS(testClassID:W, superClassID:W):B
  33.     Endif
  34.     BEGIN 
  35.             import pSuperClassTable:DATA
  36.     If qModelFarCode then
  37.                 Move.L        superClassID(FP),D0     ; D0 := Test Class Number
  38.                 Beq.S        isFALSE                    ; Exit with FALSE if Test Class is NIL
  39.                 Move.L        testClassID(FP),D1        ; D1 := object Class number
  40.                 Beq.S        isFALSE                    ; Exit with FALSE if Test Class is NIL
  41.     Else
  42.                 Move.W        superClassID(FP),D0     ; D0 := Test Class Number
  43.                 Beq.S        isFALSE                    ; Exit with FALSE if Test Class is NIL
  44.                 Move.W        testClassID(FP),D1        ; D1 := object Class number
  45.                 Beq.S        isFALSE                    ; Exit with FALSE if Test Class is NIL
  46.     Endif
  47.  
  48.                 Move.L        pSuperClassTable(A5),A0    ; A0 := Superclass Table ptr
  49.  
  50.     If qModelFarCode then
  51.                 Cmp.L        (A0),D0                    ; make sure test class ID is in range
  52.                 Bge.S        isFALSE                
  53.  
  54.                 Tst.L        D0                        ; make sure test class ID is non-negative
  55.                 Blt.s        isFALSE
  56.  
  57.                 Move.L        D0,D2                    ; make sure test class ID is even
  58.                 And.L        #1,D2
  59.                 Tst.L        D2
  60.                 Bnz.s        isFALSE
  61.  
  62.                 Cmp.L        (A0),D1                    ; make sure class ID is in range
  63.                 Bge.S        isFALSE                
  64.  
  65.                 Tst.L        D1                        ; make sure class ID is non-negative
  66.                 Blt.s        isFALSE
  67.  
  68.                 Move.L        D1,D2                    ; make sure class ID is even
  69.                 And.L        #1,D2
  70.                 Tst.L        D2
  71.                 Bnz.s        isFALSE
  72.  
  73. INOB1
  74.                 Cmp.L        D1,D0                    ; Compare object's (or superclass') number against
  75.                                                     ; Test Class'
  76.                 Beq.S        isTRUE                    ; Exit with TRUE if we get a match
  77.                 Move.L        (A0,D1.L),D1            ; D1 := Superclass of D1
  78.     Else
  79.                 Cmp.W        (A0),D0                    ; make sure test class ID is in range
  80.                 Bge.S        isFALSE                
  81.  
  82.                 Tst.W        D0                        ; make sure test class ID is non-negative
  83.                 Blt.s        isFALSE
  84.  
  85.                 Move.W        D0,D2                    ; make sure test class ID is even
  86.                 And.W        #1,D2
  87.                 Tst.W        D2
  88.                 Bnz.s        isFALSE
  89.  
  90.                 Cmp.W        (A0),D1                    ; make sure class ID is in range
  91.                 Bge.S        isFALSE                
  92.  
  93.                 Tst.W        D1                        ; make sure class ID is non-negative
  94.                 Blt.s        isFALSE
  95.  
  96.                 Move.W        D1,D2                    ; make sure class ID is even
  97.                 And.W        #1,D2
  98.                 Tst.W        D2
  99.                 Bnz.s        isFALSE
  100. INOB1
  101.                 Cmp.W        D1,D0                    ; Compare object's (or superclass') number against
  102.                                                     ; Test Class'
  103.                 Beq.S        isTRUE                    ; Exit with TRUE if we get a match
  104.                 Move.W        (A0,D1.W),D1            ; D1 := Superclass of D1
  105.     Endif
  106.                 Beq.S        isFALSE                    ; Zero means no superclass, so function returns false
  107.                 Bra.S        INOB1
  108.  
  109. isTRUE            Move.B         #1,ISCLASSIDMEMBERCLASS(FP)        ; Set return value to TRUE
  110.                 Bra.S        GoBack
  111.  
  112. isFALSE            Clr.B        ISCLASSIDMEMBERCLASS(FP)            ; Set return value to FALSE
  113. GoBack
  114.                 Return
  115.                 EndFunc
  116.  
  117.  
  118. ;---------------------------------------------------------------------------------------------------
  119.  
  120.                 Seg         'MAObjectRes'
  121. EXPORT PROCEDURE Dummy
  122.     BEGIN
  123.                 _Debugger
  124.  
  125.                 Return                        ; should never be reached
  126.                 ENDP
  127.  
  128. ;---------------------------------------------------------------------------------------------------
  129.  
  130.                 Seg         '%_MethTables'
  131. EXPORT PROCEDURE %_JMPTOTRAP
  132.     BEGIN x                                    ; suppress the LINK instruction
  133.             import Dummy
  134.                 Jmp         Dummy
  135.  
  136.                 Return                        ; should never be reached
  137.                 ENDP
  138.  
  139. ;---------------------------------------------------------------------------------------------------
  140.  
  141. ; Stack locations
  142. SelectorTableAddr    equ        0
  143. ActualReturnAddr    equ        SelectorTableAddr + 4
  144. RcvrHandleAddr        equ        ActualReturnAddr + 4
  145.  
  146. ;---------------------------------------------------------------------------------------------------
  147.  
  148.      If qDebug Then
  149.                 Seg         '%_MethTables'
  150. EXPORT PROCEDURE %_DISCIPLINEDISPATCH
  151.     BEGIN x                                    ; suppress the LINK instruction
  152.             import FAILNONOBJECT, Dummy, pDisciplineMethodCalls:DATA
  153.                 Tst.B        pDisciplineMethodCalls(A5)
  154.                 BZ.S        %_DISCIPLINEDISPATCH_PATCHPOINT
  155.                 Move.L        RcvrHandleAddr(SP), -(SP)    ;receiver handle for FailNonObject
  156.                 JSR         FAILNONOBJECT
  157.                 
  158.         Export %_DISCIPLINEDISPATCH_PATCHPOINT
  159. %_DISCIPLINEDISPATCH_PATCHPOINT:
  160.                 Jmp            Dummy            ; now dispatch
  161.  
  162.                 Return                        ; should never be reached
  163.                 ENDP
  164.       EndIf
  165.  
  166.  
  167. ;---------------------------------------------------------------------------------------------------
  168. ; PROCEDURE MethodDispatch ( 'uses nonstandard stack params ' );
  169. ;            (SP)        = selector table address    (first return address on stack)
  170. ;            4(SP)        = actual return address        (selector proc caller's return address)
  171. ;            8(SP)        = receiver                    (the object being dispatched for)
  172.  
  173. ; Uses only scratch registers: A0/A1/D0/D1/D2.  A5 must be correct.
  174.  
  175. ; Selector Proc Format
  176. ; --------------------
  177. ; JSR %_JmpToTrap
  178. ;   Selector Table
  179. ;   --------------
  180. ;   Number of repeating entries - 1
  181. ;   Cached ClassID
  182. ;   Cached Implementation address (A5 JT relative (16 bit))
  183. ;     Repeating Entries
  184. ;     -----------------
  185. ;     ClassID
  186. ;     Implementation address (A5 JT relative (16 bit))
  187. ;     .
  188. ;     .
  189. ;
  190.  
  191. ; Table locations
  192.     If qModelFarCode then
  193. NumberOfEntries        equ        0
  194. CacheClassID        equ        NumberOfEntries + 2
  195. CacheImplementation    equ        CacheClassID + 4    ;(32 bit absolute)
  196. FirstClassID        equ        CacheImplementation + 4
  197. FirstImplementation    equ        FirstClassID + 4    ;(32 bit absolute)
  198.  
  199. SizeOfEntry            equ        8
  200.     Else
  201. NumberOfEntries        equ        0
  202. CacheClassID        equ        NumberOfEntries + 2
  203. CacheImplementation    equ        CacheClassID + 2    ;(A5 JT relative (16 bit))
  204. FirstClassID        equ        CacheImplementation + 2
  205. FirstImplementation    equ        FirstClassID + 2    ;(A5 JT relative (16 bit))
  206.  
  207. SizeOfEntry            equ        4
  208.  
  209.     EndIf
  210.                 Seg         '%_MethTables'
  211.     If qModelFarCode then
  212. EXPORT PROCEDURE %_NEWMETHOD
  213.     BEGIN x,                                        ; suppress the link instruction
  214.             import pSuperClassTable:DATA
  215.              import PDISPATCHERRORPROC:DATA
  216.                  Move.L     RcvrHandleAddr(SP),A1        ; A1 := receiver handle
  217.                 Move.L        (A1),A1                 ; A1 := receiver ptr
  218.                 Move.L        (A1),D0                 ; D0 := receiver's ClassID
  219.  
  220.                 Move.L        (SP)+,A0        ; A0 := Method table ptr
  221.                                             ; immediately follows selector
  222.                 Move.W        (A0)+,D1        ; D1 := number of implementations of method (-1)
  223.                 Cmp.L        (A0)+,D0         ; cached ClassID versus receiver ClassID
  224.                 Bne.S        search            ; Not Equal => must search table
  225. CacheOut        Move.L         (A0),A0            ; A0 := 32 bit Jump table address of method
  226.                 Jmp         (A0)            ;
  227. search
  228.                 Move.L        D0,-(A0)         ; cache the ClassID
  229.                 Move.L        A0,D2            ; D2 := ptr to ClassID cache
  230. loopa
  231.                 AddQ.L        #SizeOfEntry,A0    ; A0 := ptr to next ClassID in table
  232.                 Cmp.L        (A0),D0         ; next ClassID versus given ClassID
  233.                 DBcc        D1,loopa        ; fall through if (A0) unsigned <= D0
  234.                 Beq.S        found            ; Eq => found it
  235.                 Move.L        pSuperClassTable(A5),A1    ; A1 := ptr to Superclass table
  236.                 Bra.S        doSuper         ; Get Superclass
  237. loopb
  238.                 AddQ.L        #SizeOfEntry,A0    ; A0 := ptr to next ClassID in table
  239. loop2
  240.                 Cmp.L        (A0),D0         ; next ClassID versus given ClassID
  241.                 DBcc        D1,loopb        ; fall through if (A0) unsigned <= D0
  242.                 Beq.S        found            ; Eq => found it
  243. doSuper
  244.                 Move.L        0(A1,D0.L),D0    ; D0 := SuperClassID of D0 (D0 is always even!)
  245.                 Bne.S        loop2            ; Not Equal => still worth searching
  246.  
  247.     ; Error condition: method not found
  248.                 Move.L        D2,A1            ; A1 := ptr to ClassID cache
  249.                 Clr.L        (A1)
  250.                 Move.L        PDISPATCHERRORPROC(A5),A1 ; ptr to error routine
  251. ErrorOut        Jmp         (A1)
  252.  
  253. found
  254.                 Move.L        D2,A1            ; A1 := ptr to ClassID cache
  255.                 Move.L        4(A0),A0         ; A0 := 32 bit Jump table address of method
  256.                 Move.L        A0,4(A1)        ; stow Implementation in cache
  257. TableOut        Jmp         (A0)            ; sayonara
  258.  
  259.                 Return                        ; should never be reached
  260.     Else
  261. EXPORT PROCEDURE %_NEWMETHOD
  262.     BEGIN x,                                        ; suppress the link instruction
  263.             import pSuperClassTable:DATA
  264.              import PDISPATCHERRORPROC:DATA
  265.                  Move.L     RcvrHandleAddr(SP),A1        ; A1 := receiver handle
  266.                 Move.L        (A1),A1                 ; A1 := receiver ptr
  267.                 Move.W        (A1),D0                 ; D0 := receiver's ClassID
  268.  
  269.                 Move.L        (SP)+,A0        ; A0 := Method table ptr
  270.                                             ; immediately follows selector
  271.                 Move.W        (A0)+,D1        ; D1 := number of implementations of method (-1)
  272.                 Cmp.W        (A0)+,D0         ; cached ClassID versus receiver ClassID
  273.                 Bne.S        search            ; Not Equal => must search table
  274.                 Move.W        (A0),A1            ; A1 := A5 relative offset to method
  275. CacheOut        Jmp         (A5,A1.W)        ; via Jump Table
  276. search
  277.                 Move.W        D0,-(A0)         ; cache the ClassID
  278.                 Move.L        A0,D2            ; D2 := ptr to ClassID cache
  279. loopa
  280.                 AddQ.L        #SizeOfEntry,A0    ; A0 := ptr to next ClassID in table
  281.                 Cmp.W        (A0),D0         ; next ClassID versus given ClassID
  282.                 DBcc        D1,loopa        ; fall through if (A0) unsigned <= D0
  283.                 Beq.S        found            ; Eq => found it
  284.                 Move.L        pSuperClassTable(A5),A1    ; A1 := ptr to Superclass table
  285.                 Bra.S        doSuper         ; Get Superclass
  286. loopb
  287.                 AddQ.L        #SizeOfEntry,A0    ; A0 := ptr to next ClassID in table
  288. loop2
  289.                 Cmp.W        (A0),D0         ; next ClassID versus given ClassID
  290.                 DBcc        D1,loopb        ; fall through if (A0) unsigned <= D0
  291.                 Beq.S        found            ; Eq => found it
  292. doSuper
  293.                 Move.W        0(A1,D0.W),D0    ; D0 := SuperClassID of D0 (D0 is always even!)
  294.                 Bne.S        loop2            ; Not Equal => still worth searching
  295.  
  296.     ; Error condition: method not found
  297.                 Move.L        D2,A1            ; A1 := ptr to ClassID cache
  298.                 Clr.L        (A1)
  299.                 Move.L        PDISPATCHERRORPROC(A5),A1 ; ptr to error routine
  300. ErrorOut        Jmp         (A1)
  301.  
  302. found
  303.                 Move.L        D2,A1            ; A1 := ptr to ClassID cache
  304.                 Move.W        2(A0),A0         ; A0 := A5 relative offset to method
  305.                 Move.W        A0,2(A1)        ; stow Implementation in cache
  306. TableOut        Jmp         (A5,A0.W)        ; via Jump Table
  307.  
  308.                 Return                        ; should never be reached
  309.  
  310.     Endif
  311.  
  312. ;---------------------------------------------------------------------------------------------------
  313. ; This routine copies the address of some symbols created by the linker that begin with a '%'
  314. ; to some globally available variables accessible from C++. C++ identifiers can't contain a '%'.
  315. ; This is called once by InitUObject.
  316.  
  317.             Seg            '%_MethTables'
  318. EXPORT PROCEDURE INITLINKERSYMBOLS
  319.     BEGIN
  320.             import %_JMPTOTRAP:CODE
  321.             import gJmpToTrapPatchPoint:DATA
  322.             import %_NEWMETHOD:CODE
  323.             import gMethDispAddr:DATA
  324.             import %_DISCIPLINEDISPATCH:CODE
  325.             import gDisciplinedMethDispAddr:DATA
  326.             import %_DISCIPLINEDISPATCH_PATCHPOINT:CODE
  327.             import gDisciplinedJmpToTrapPatchPoint:DATA
  328.             import %_CLASSINFO:CODE
  329.             import gClassInfo:DATA
  330.             import %_SUPERCLASSTABLE:CODE
  331.             import gSuperClassTable:DATA
  332.             import %_CLASSTABLE:CODE
  333.             import gClassTable:DATA
  334.             import %_SELECTORPROCTABLE:CODE
  335.             import gSelectorProcTable:DATA
  336.  
  337.                 lea        %_JMPTOTRAP,A0
  338.                 Move.L    A0,gJmpToTrapPatchPoint(A5)
  339.                 
  340.                 lea        %_NEWMETHOD,A0
  341.                 Move.L    A0,gMethDispAddr(A5)
  342.                 
  343.     If qDebug Then                
  344.                 lea        %_DISCIPLINEDISPATCH,A0
  345.                 Move.L    A0,gDisciplinedMethDispAddr(A5)
  346.  
  347.                 lea        %_DISCIPLINEDISPATCH_PATCHPOINT,A0
  348.                 Move.L    A0,gDisciplinedJmpToTrapPatchPoint(A5)
  349.     Endif
  350.  
  351.     If qModelFarCode then
  352.                 lea        %_SUPERCLASSTABLE(A5),A0
  353.                 Move.L    A0,gSuperClassTable(A5)
  354.                 
  355.                 lea        %_CLASSTABLE(A5),A0
  356.                 Move.L    A0,gClassTable(A5)
  357.  
  358.                 lea        %_SELECTORPROCTABLE(A5),A0
  359.                 Move.L    A0,gSelectorProcTable(A5)
  360.     Else
  361.                 lea        %_CLASSINFO(A5),A0
  362.                 Move.L    A0,gClassInfo(A5)
  363.     Endif
  364.  
  365.                 Return
  366.                 ENDP
  367.  
  368. ;---------------------------------------------------------------------------------------------------
  369. ; Until the linker gets fixed to used different symbols the following routines
  370. ; redirect to C++ routines in UPascalObject.cp.
  371.  
  372.                 Seg         'MAObjectRes'
  373.                 
  374. EXPORT PROCEDURE %_OPTINOBJ
  375.     BEGIN x                                    ; suppress the LINK instruction
  376.             import __OPTINOBJ
  377.             
  378.                 Jmp         __OPTINOBJ        ; Go there directly!
  379.  
  380.                 Return                        ; should never be reached
  381.                 ENDP
  382.  
  383. EXPORT PROCEDURE %_ObjError
  384.     BEGIN x                                    ; suppress the LINK instruction
  385.             import __ObjError
  386.             
  387.                 Jmp         __ObjError        ; Go there directly!
  388.  
  389.                 Return                        ; should never be reached
  390.                 ENDP
  391.  
  392. EXPORT PROCEDURE %_OBCHK
  393.     BEGIN x                                    ; suppress the LINK instruction
  394.             import __OBCHK
  395.             
  396.                 Jmp         __OBCHK        ; Go there directly!
  397.  
  398.                 Return                        ; should never be reached
  399.                 ENDP
  400.  
  401. EXPORT PROCEDURE %_OBDISP
  402.     BEGIN x                                    ; suppress the LINK instruction
  403.             import __OBDISP
  404.             
  405.                 Jmp         __OBDISP        ; Go there directly!
  406.  
  407.                 Return                        ; should never be reached
  408.                 ENDP
  409.  
  410.  
  411.  
  412. ;---------------------------------------------------------------------------------------------------
  413. ; LOW LEVEL required to satisfy fussy linker.  Even though the optimizer
  414. ; redirects these entry points they must at least be present.
  415.  
  416.                 Seg            'MAObjectRes'
  417.                 
  418. EXPORT PROCEDURE %_INITOBJ
  419.     BEGIN
  420.                 _Debugger
  421.                 Return                        ; should never be reached
  422.                 ENDP
  423.  
  424. EXPORT PROCEDURE %_INOBJ
  425.     BEGIN
  426.                 _Debugger
  427.                 Return                        ; should never be reached
  428.                 ENDP
  429.  
  430. EXPORT PROCEDURE %_OptInitObj
  431.     BEGIN
  432.                 _Debugger
  433.                 Return                        ; should never be reached
  434.                 ENDP
  435.  
  436. EXPORT PROCEDURE %_OptSetCI
  437.     BEGIN
  438.                 _Debugger
  439.                 Return                        ; should never be reached
  440.                 ENDP
  441.  
  442. EXPORT PROCEDURE %_METHOD
  443.     BEGIN
  444.                 _Debugger
  445.                 Return                        ; should never be reached
  446.                 ENDP
  447.  
  448.                     END